Shareware Grab Bag/Shareware Grab Bag.iso/007/tttool30.arc/IO.TTT

Text File | 1986-09-28 | 16.0 KB | 551 lines

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                                                                           }
{           T E C H N O J O C K S     T U R B O    T O O L K I T            }
{                                                                           }
{                      Module   :   IO.TTT                                  }
{                                                                           }
{                      Version  :   3.0 , October 1, 1986                   }
{                                                                           }
{                      Purpose  :   Fullscreen editing procedures           }
{                                                                           }
{                 Requirements  :   Decl.TTT                                }
{                                   Fastwrit.TTT                            }
{                                   Window.ttt                              }
{                                   Misc.ttt                                }
{                                                                           }
{   Procedures:                                                             }
{        IO_Setfields(No_of_fields:byte);                                   }
{        IO_SetColors(HiFore,Hiback,LoFore,LoBack,MsgFore,MsgBack:byte);    }
{        IO_DefineMsg(DefID,DefX,DefY : byte; DefString : string80);        }
{        IO_DefineStr(DefID,DefU,DefD,DefL,DefR,DefX,DefY:byte;             }
{                        Var DefString : string80;                          }
{                        DefFormat : string80);                             }
{        IO_HelpProc(location : integer);                                   }
{        IO_DisplayFields;                                                  }
{        IO_AllowEsc(OK:boolean);                                           }
{        IO_SoundBeeper(OK:boolean);                                        }
{        IO_Edit(var Return_code : integer);                                }
{        IO_ResetFields;                                                    }
{                                                                           }
{                                                Bob Ainsbury               }
{                                                Technojock                 }
{                                                Houston                    }
{                                                [phone]             }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

Procedure Abend(Code:byte;value:real);    {fatal error -- msg and halt}
var Message:string80;
begin
{Clrscr;}
Case Code of
1 : Message :=
'Fatal Error 1 : Invalid value of '+Real_to_Str(value,0)+
' in IO_SetFields with a MaxInputFields of '+Real_to_Str(MaxInputFields,0);
2 : Message :=
'Fatal Error 2 : Insufficient Memory on Heap. Available '
+Real_to_Str(MemAvail_in_Bytes,0)+'. Required '+Real_to_Str(value,0);
3 : Message :=
'Fatal Error 3 : Define IO_Setfields before IO_DefineStr';
4 : Message :=
'Fatal Error 4 : IO_DefineStr ID: '+Real_to_Str(value,0)+' out of range';
5 : Message :=
'Fatal Error 5 : Invalid exit field defined in IO_DefinStr ID: '
+Real_to_Str(value,0);
6 : message :=
'Fatal Error 6 : Invalid X or Y value defined in IO_DefineStr ID: '
+Real_to_Str(value,0);
7 : Message :=
'Fatal Error 7 : Define IO_Setfields before IO_DefineMsg';
8 : Message :=
'Fatal Error 8 : IO_DefineMsg ID: '+Real_to_Str(value,0)+' out of range';
9 : message :=
'Fatal Error 9 : Invalid X or Y value defined in IO_DefineMsg ID: '
+Real_to_Str(value,0);
10 : Message :=
'Fatal Error 10 : Only use IO_ResetFields after IO_Setfields';
11 : Message :=
'Fatal Error 11 : IO_Setfields already operative, reset with IO_Resetfields';
else Message := 'Aborting';
end; {case}
WriteAT(1,12,yellow,red,Message);
Repeat Until keypressed;
Halt;
end;    {proc Abend}

Procedure Ding;
begin
 If IO_Settings.IO_BeepOn then
  sound(750);delay(150);nosound;
end;    {proc Ding}

Procedure Jumpto(location:integer);
begin
 inline($1e/$55/$8b/$ec/$8b/$5e/$0a/$ff/$d3/$5d/$1f);
end;

Procedure IO_HelpProc(location : integer);
begin
 IO_Settings.HelpAddress := location;
end;

Procedure InsertMode;       {change cursor style when in insert mode}
begin
IO_Settings.IO_Insert := not IO_Settings.IO_Insert;
If IO_Settings.IO_Insert then
 SizeCursor(4,7)
else
 SizeCursor(6,7);
end;

Procedure IO_Setfields(No_of_fields:byte);
var I:integer;
Room_needed : real;
begin
If IO_Settings.IO_FieldsSet then Abend(11,0);       {already set}
If No_of_Fields in [1..MaxInputFields] then
begin
 Room_needed := sizeof(FieldDefn[0]^)*(1+No_of_fields);
 If MemAvail_in_bytes > Room_needed then
 begin
  For I := 0 to No_of_fields do
  begin
   New(FieldDefn[I]);
   New(FieldDefn[I]^.InString);
   with FieldDefn[I]^ do
   begin
    Upfield     := 0;
    Downfield   := 0;
    Leftfield   := 0;
    Rightfield  := 0;
    X           := 0;
    Y           := 0;
    InString^   := '';
    StrLength   := 0;
    Format      := '';
    Message     := '';
    MsgX        := 0;
    MsgY        := 0;
    CursorX     := 0;
    CursorInit  := 0;
    StrLocX     := 1;
   end;
  end;
  IO_Settings.TotalFields := No_of_Fields;
  IO_Settings.IO_FieldsSet := true;
 end
 else {not enough heap space}
  Abend(2,Room_needed); {end MemAvail If clause}
end
else  {Invalid No_of_fields}
 Abend(1,No_of_fields);
end;  {Proc IO_SetFields}

Procedure IO_SetColors(HiFore,Hiback,LoFore,LoBack,MsgFore,MsgBack:byte);
begin
With IO_Settings do
begin
 HiF := HiFore;
 HiB := HiBack;
 LoF := LoFore;
 LoB := LoBack;
 MsgF := MsgFore;
 MsgB := MsgBack;
end;
end;    {Proc IO_SetColors}

Procedure IO_DefineMsg(DefID,DefX,DefY : byte; DefString : string80);
begin
If not IO_Settings.IO_FieldsSet then abend(7,0);
If (DefID < 1) or (DefID > IO_Settings.TotalFields) then abend(8,DefID);
If (DefX < 1) or (DefX > 80) or (DefY < 1) or (DefY > 25) then abend(9,DefID);
With FieldDefn[Defid]^ do
begin
 MsgX := DefX;
 MsgY := DefY;
 Message := DefString;
end;
end;  {proc IO_DefineMsg}

Procedure IO_DefineStr(DefID,DefU,DefD,DefL,DefR,DefX,DefY:byte;
                         Var DefString : string80;
                         DefFormat : string80);

             Function Max_string_length : byte;
             var I,Counter : byte;
             begin
             Counter := 0;
             For I := 1 to length(DefFormat) do
              if (DefFormat[I] in FmtChars) then
               Counter := counter + 1;
             Max_string_length := Counter;
             end;  {sub func Max_String_Length}

             Function  Pos_of_First_Input_Char: byte;
             var Counter : byte;
             begin
             Counter := 0;
             Repeat
              Counter := Counter + 1;
             Until DefFormat[Counter] in FmtChars;
             Pos_of_First_Input_Char := FieldDefn[DefID]^.X + counter - 1;
             end;
begin
If not IO_Settings.IO_FieldsSet then Abend(3,0);
If (DefID < 1) or (DefID>IO_Settings.TotalFields) then Abend(4,Defid);
If  (DefU < 0)  or (DefU > IO_Settings.TotalFields)
 or (DefD < 0)  or (DefD > IO_Settings.TotalFields)
 or (DefL < 0)  or (DefL > IO_Settings.TotalFields)
 or (DefR < 0)  or (DefR > IO_Settings.TotalFields)
then Abend(5,Defid);
If  (DefX < 1) or (DefX > 80)
 or (DefY < 1) or (DefY > 25)
then Abend(6,Defid);
With FieldDefn[DefID]^ do
begin
    Upfield    := DefU;
    Downfield  := DefD;
    Leftfield  := DefL;
    Rightfield := DefR;
    X          := DefX;
    Y          := DefY;
    InString   := ptr(seg(DefString),ofs(DefString));
    StrLength  := Max_String_length;
    Format     := DefFormat;
    CursorX    := Pos_of_First_Input_Char;
    CursorInit := Pos_of_First_Input_Char;
end;
end; {proc IO_DefineStr}

Function IO_FmtStr(Str,Fmt:string80):string80;
var
TempStr : string80;
I,J : byte;
begin
 J := 0;
 For I := 1 to length(Fmt) do
 begin
  If not (Fmt[I] in FmtChars) then
  begin
   TempStr[I] := Fmt[I] ;  {force any none format charcters into string}
   J := J + 1;
  end
  else    {format character}
  begin
   If I - J <= length(Str) then
    TempStr[I] := Str[I - J]
   else
    TempStr[I] := ' ';    {pad with blanks}
  end;
 end;
 TempStr[0] := char(length(Fmt));  {set initial byte to string length}
 IO_FmtStr := Tempstr;
end;  {Func FmtStr}

Function Underline(Str:string80):string80;
var I : integer;
begin
If IO_Settings.IO_PutUnderline then
 for I := 1 to length(Str) do
  If Str[I] = ' ' then Str[I] := '_';
Underline := Str;
end;   {func Underline}

Procedure Hilight(ID:byte);      {display cell in bright colors}
begin
with  FieldDefn[ID]^ do
WriteAT(X,Y,IO_Settings.HiF,IO_Settings.HiB,Underline(IO_FmtStr(InString^,Format)));
end;

Procedure LoLight(ID:byte);      {display cell in dim colors}
begin
with  FieldDefn[ID]^ do
WriteAT(X,Y,IO_Settings.LoF,IO_Settings.LoB,Underline(IO_FmtStr(InString^,Format)));
end;

Procedure IO_DisplayFields;
var I : integer;
begin
For I :=  1 to IO_Settings.TotalFields do
 LoLight(I);
IO_Settings.Displayed  := true;
end;

Procedure IO_AllowEsc(OK:boolean);
begin
 IO_Settings.IOEsc := OK;
end;    {proc IO_AllowEsc}

Procedure IO_SoundBeeper(OK:boolean);
begin
 IO_Settings.IO_BeepOn := OK;
end;    {proc IO_SoundBeeper}

Procedure IO_ResetFields;
var I : integer;
begin
If not IO_Settings.IO_FieldsSet then abend(10,0);
For I := 1 to IO_Settings.TotalFields do
 Dispose(FieldDefn[I]);
With IO_Settings do
begin
 IO_FieldsSet := false;
 TotalFields := 0;
 IOEsc := false;
 Displayed := false;
 IO_Beepon := true;
 IO_PutUnderline := true;
 IO_Insert := false;
 CurrentField := 1;
 HelpAddress := 0;
end; {with}
end; { proc IO_ResetFields }

{
****************************
*      Main Procedure      *
****************************
}

Procedure IO_Edit(var Return_code : integer);
const finished : boolean = false;
var  OldLine : line;

    Procedure DisplayMessage(ID:byte);
    var I,LocC : integer;
    begin
    For I := 1 to 80 do
    begin
     LocC := (I-1)*2 + (FieldDefn[ID]^.MsgY-1)*160;
     OldLine[I].C := chr(mem[$b800:LocC]);
     OldLine[I].A := mem[$B800:LocC+1];
    end;
    With FieldDefn[ID]^ do
     WriteAT(MsgX,MsgY,IO_Settings.MsgF,IO_Settings.MsgB,Message);
    end; {sub sub proc DisplayMessage}

    Procedure RemoveMessage(ID:byte);
    var I,LocC : integer;
    begin
    For I := 1 to 80 do
    begin
     LocC := (I-1)*2 + (FieldDefn[ID]^.MsgY-1)*160;
     Mem[$B800:LocC] := ord(OldLine[I].C);
     Mem[$B800:locC + 1] := OldLine[I].A;
    end;
    end; {sub sub proc RemoveMessage}

  Procedure Change_Fields(ID:byte);
  begin
   LoLight(IO_Settings.CurrentField);
   If FieldDefn[IO_Settings.CurrentField]^.MsgX > 0 then
    RemoveMessage(IO_Settings.CurrentField);
   If ID = 0 then
   begin
    Finished := true;
    Return_Code := 0;
   end
   else
   begin
    IO_Settings.CurrentField := ID;
    If IO_Settings.IO_Insert = true then      {switch insert off}
      InsertMode;
    HiLight(IO_Settings.CurrentField);
   If FieldDefn[IO_Settings.CurrentField]^.MsgX > 0 then
    DisplayMessage(IO_Settings.CurrentField);
    With FieldDefn[IO_Settings.CurrentField]^ do
    GotoXY(CursorX,Y);
    Ding;
   end;  {If ID = 0};
  end;  {proc change fields}

  Procedure Erase_Field(ID:byte);
  begin
  with FieldDefn[ID]^ do
  begin
   Instring^ := '';
   CursorX   := CursorInit;
   StrLocX := 1;
  end;
  end;

  Procedure Global_Erase;
  var I : integer;
  begin
  {MayBe paint an are you sure window}
  For I :=  1 to IO_Settings.TotalFields do
   Erase_Field(I);
  IO_DisplayFields;
  IO_Settings.CurrentField := 1;
  end;

  Procedure Cursor_Right;
  begin
  With FieldDefn[IO_Settings.CurrentField]^ do
  begin
   If (StrLocX <= length(InString^)) and (StrLocX < StrLength) then
   begin
    StrLocX := StrLocX + 1;
    Repeat
     CursorX := CursorX + 1;
    Until Format[CursorX + 1 - X] in FmtChars;
   end;
   GotoXY(CursorX,Y);
  end; {with}
  end; {Proc Cursor_Right}

  Procedure Cursor_Left;
  begin
  With FieldDefn[IO_Settings.CurrentField]^ do
  begin
   If StrLocX > 1 then
   begin
    StrLocX := StrLocX - 1;
    Repeat
     CursorX := CursorX - 1;
    Until Format[CursorX + 1 - X] in FmtChars;
   end;
  end;  {with}
  end;  {Proc Cursor_left}

  Procedure Delete_Char;
  var
  Temp : boolean;
  I : integer;
  begin
  Temp := false;                                 {insert a space if there are}
  with FieldDefn[IO_Settings.CurrentField]^ do   {non format characters}
  begin
   For I := 1 to length(Format) do
   If not (Format[I] in FmtChars) then
    Temp := true;
   Delete(InString^,StrLocX,1);
   If Temp = true then
    Insert(' ',Instring^,StrlocX);
  end;  {with}
  end;  {Delete_Chars}

  Procedure Backspaced;
  begin
  with FieldDefn[IO_Settings.CurrentField]^ do
  begin
   If StrLocX > 1 then
   begin
    Cursor_Left;
    Delete(InString^,StrLocX,1);
   end;
  end;  {with}
  end;  { Proc Backspaced }

  Procedure Activity;
  var K : char;
  begin
  Wait_for_KeyPress(K);
  If K in [IOEsc1, IOEsc2, IOEnter, IOBackSp, IOTab] then Funckey := true;
  If Funckey = true then
  begin
   Case K of
   IOEsc1 : begin
             If IO_Settings.IOEsc then
             begin
              Finished := true;
              Return_Code := 1;
             end
             else
              Ding;
            end;

   IOEsc2 : begin
             If IO_Settings.IOEsc then
             begin
              Finished := true;
              Return_Code := 2;
             end
             else
              Ding;
            end;

   IOFinish : begin
               Finished := true;
               Return_code := 0;
              end;

   IORightFld,
   IOTab,
   IOEnter : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.RightField);

   IOLeftFld,
   IOShiftTab :Change_Fields(FieldDefn[IO_Settings.CurrentField]^.LeftField);

   IOBackSp : Backspaced;

   IODel    : Delete_Char;

   IOLeft   : Cursor_Left;

   IORight  : Cursor_Right;

   IOUp     : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.UpField);

   IODown   : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.DownField);

   IOErase    : Erase_Field(IO_Settings.CurrentField);

   IOTotErase : Global_Erase;

   IOIns      : InsertMode;

   IOHelp     : If IO_Settings.HelpAddress <> 0 then
                 Jumpto(IO_Settings.HelpAddress);

   else Ding;
   end; {case}
  end
  else {not a function key}
  If K in [#32..#126] then
  with FieldDefn[IO_settings.CurrentField]^ do
  begin
   If Format[CursorX - X + 1] = '!' then K := upcase(K);
   If ((K in ['0'..'9','.']) and (Format[CursorX - X + 1] = '#'))
   or ((K in ['a'..'z','A'..'Z',' ',',','.',';',':']) and
       (Format[CursorX - X + 1] = '@'))
   or (Format[CursorX - X + 1] = '*')
   or (Format[CursorX - X + 1] = '!') then
   begin
    If IO_Settings.IO_Insert then          {in insert mode}
    begin
     If length(Instring^) < StrLength then
     begin
      Insert(K,Instring^,StrLocX);
      Cursor_Right;
     end
     else Ding;
    end
    else                                    {in overlay mode}
    begin
     Delete(Instring^,StrLocX,1);
     Insert(K,Instring^,StrLocX);
     Cursor_Right;
    end; {If insert}
   end
   else Ding; {end if K in statement}
  end;  {with and big IF Funckey}
  HiLight(IO_Settings.CurrentField);
  With FieldDefn[IO_Settings.CurrentField]^ do
    GotoXY(CursorX,Y);
  end;    {Proc Activity}


begin   {IO_Edit}
If IO_Settings.Displayed = false then IO_DisplayFields;
Hilight(IO_Settings.CurrentField);
If FieldDefn[IO_Settings.CurrentField]^.MsgX > 0 then
DisplayMessage(IO_Settings.CurrentField);
GotoXY(FieldDefn[IO_Settings.CurrentField]^.CursorX,
       FieldDefn[IO_Settings.CurrentField]^.Y);
Finished := false;
repeat
 Activity
until Finished;
end;   {IO_Edit}